home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / DEFMACRO.LSP < prev    next >
Lisp/Scheme  |  1994-02-05  |  30KB  |  625 lines
  1. ;;;; File DEFMACRO.LSP
  2. ;;; Macro DEFMACRO und einige Hilfsfunktionen für komplizierte Macros.
  3. ;;; 1. 9. 1988
  4. ;;; Adaptiert an DEFTYPE am 10.6.1989
  5.  
  6. (in-package "SYSTEM")
  7.  
  8. ;; Import aus CONTROL.Q:
  9.  
  10. #| (SYSTEM::PARSE-BODY body &optional docstring-allowed env)
  11.    expandiert die ersten Formen in der Formenliste body (im Macroexpansions-
  12.    Environment env), entdeckt dabei auftretende Deklarationen (und falls
  13.    docstring-allowed=T, auch einen Docstring) und liefert drei Werte:
  14.    1. body-rest, die restlichen Formen,
  15.    2. declspec-list, eine Liste der aufgetretenen Decl-Specs,
  16.    3. docstring, ein aufgetretener Docstring oder NIL.
  17. |#
  18. #| (SYSTEM::KEYWORD-TEST arglist kwlist)
  19.    testet, ob arglist (eine paarige Keyword/Value-Liste) nur Keywords
  20.    enthält, die auch in der Liste kwlist vorkommen, oder aber ein
  21.    Keyword/Value-Paar :ALLOW-OTHER-KEYS mit Value /= NIL enthält.
  22.    Wenn nein, wird ein Error ausgelöst.
  23. |#
  24. #| (keyword-test arglist kwlist) überprüft, ob in arglist (eine Liste
  25. von Keyword/Value-Paaren) nur Keywords vorkommen, die in kwlist vorkommen,
  26. oder ein Keyword/Value-Paar mit Keyword = :ALLOW-OTHER-KEYS und Value /= NIL
  27. vorkommt. Sollte dies nicht der Fall sein, wird eine Errormeldung ausgegeben.
  28.  
  29. (defun keyword-test (arglist kwlist)
  30.   (let ((unallowed-arglistr nil)
  31.         (allow-other-keys-flag nil))
  32.     (do ((arglistr arglist (cddr arglistr)))
  33.         ((null arglistr))
  34.       (if (eq (first arglistr) ':ALLOW-OTHER-KEYS)
  35.           (if (second arglistr) (setq allow-other-keys-flag t))
  36.           (do ((kw (first arglistr))
  37.                (kwlistr kwlist (cdr kwlistr)))
  38.               ((or (null kwlistr) (eq kw (first kwlistr)))
  39.                (if (and (null kwlistr) (null unallowed-arglistr))
  40.                    (setq unallowed-arglistr arglistr)
  41.     ) )   )   ))
  42.     (unless allow-other-keys-flag
  43.       (if unallowed-arglistr
  44.         (cerror #+DEUTSCH "Beide werden übergangen."
  45.                 #+ENGLISH "It will be ignored."
  46.                 #+FRANCAIS "Ignorer les deux."
  47.                 #+DEUTSCH "Unzulässiges Keyword ~S mit Wert ~S"
  48.                 #+ENGLISH "Invalid keyword-value-pair: ~S ~S"
  49.                 #+FRANCAIS "Mot-clé illégal ~S, valeur ~S"
  50.                 (first unallowed-arglistr) (second unallowed-arglistr)
  51.     ) ) )
  52. ) )
  53. ; Definition in Assembler siehe CONTROL.Q
  54. |#
  55.  
  56. (defun macro-call-error (macro-form)
  57.   (error #+DEUTSCH "Der Macro ~S kann nicht mit ~S Argumenten aufgerufen werden: ~S"
  58.          #+ENGLISH "The macro ~S may not be called with ~S arguments"
  59.          #+FRANCAIS "Le macro ~S ne peut pas être appelé avec ~S arguments : ~S"
  60.          (car macro-form) (1- (length macro-form)) macro-form
  61. ) )
  62.  
  63. (proclaim '(special
  64.         %restp ; gibt an, ob &REST/&BODY/&KEY angegeben wurde,
  65.                ; also ob die Argumentanzahl unbeschränkt ist.
  66.  
  67.         %min-args ; gibt die Anzahl der notwendigen Argumente an
  68.  
  69.         %arg-count ; gibt die Anzahl der Einzelargumente an
  70.                    ; (notwendige und optionale Argumente, zusammengezählt)
  71.  
  72.         %let-list ; umgedrehte Liste der Bindungen, die mit LET* zu machen sind
  73.  
  74.         %keyword-tests ; Liste der KEYWORD-TEST - Aufrufe, die einzubinden sind
  75.  
  76.         %default-form ; Default-Form für optionale und Keyword-Argumente,
  77.                    ; bei denen keine Default-Form angegeben ist.
  78.                    ; =NIL normalerweise, = (QUOTE *) für DEFTYPE.
  79. )          )
  80. #|
  81. (ANALYZE1 lambdalist accessexp name wholevar)
  82. analysiert eine Macro-Lambdaliste (ohne &ENVIRONMENT). accessexp ist der
  83. Ausdruck, der die Argumente liefert, die mit dieser Lambdaliste zu matchen
  84. sind.
  85.  
  86. (ANALYZE-REST lambdalistr restexp name)
  87. analysiert den Teil einer Macro-Lambdaliste, der nach &REST/&BODY kommt.
  88. restexp ist der Ausdruck, der die Argumente liefert, die mit diesem
  89. Listenrest zu matchen sind.
  90.  
  91. (ANALYZE-KEY lambdalistr restvar name)
  92. analysiert den Teil einer Macro-Lambdaliste, der nach &KEY kommt.
  93. restvar ist das Symbol, das die restlichen Argumente enthalten wird.
  94.  
  95. (ANALYZE-AUX lambdalistr name)
  96. analysiert den Teil einer Macro-Lambdaliste, der nach &AUX kommt.
  97.  
  98. (REMOVE-ENV-ARG lambdalist name)
  99. entfernt das Paar &ENVIRONMENT/Symbol aus einer Macro-Lambdaliste,
  100. liefert zwei Werte: die verkürzte Lambdaliste und das als Environment zu
  101. verwendende Symbol (oder die Lambdaliste selbst und NIL, falls &ENVIRONMENT
  102. nicht auftritt).
  103.  
  104. (MAKE-LENGTH-TEST symbol)
  105. kreiert aus %restp, %min-args, %arg-count eine Testform, die bei Auswertung
  106. anzeigt, ob der Inhalt der Variablen symbol als Aufruferform zum Macro
  107. dienen kann.
  108.  
  109. (MAKE-MACRO-EXPANSION macrodef)
  110. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  111. 1. den Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)),
  112. 2. name, ein Symbol,
  113. 3. lambdalist,
  114. 4. docstring (oder NIL, wenn keiner da).
  115.  
  116. (MAKE-MACRO-EXPANDERCONS macrodef)
  117. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  118. das fürs FENV bestimmte Cons (SYSTEM::MACRO . expander).
  119. |#
  120.  
  121. (%proclaim-constant 'macro-missing-value (list 'macro-missing-value))
  122. ; einmaliges Objekt
  123.  
  124. (%putd 'analyze-aux
  125.   (function analyze-aux
  126.     (lambda (lambdalistr name)
  127.       (do ((listr lambdalistr (cdr listr)))
  128.           ((atom listr)
  129.            (if listr
  130.              (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  131.                      #+ENGLISH "The rest of the lambda list will be ignored."
  132.                      #+FRANCAIS "Ignorer ce qui suit."
  133.                      #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &AUX."
  134.                      #+ENGLISH "The lambda list of macro ~S contains a dot after &AUX."
  135.                      #+FRANCAIS "La liste lambda du macro ~S contient un point après &AUX."
  136.                      name
  137.           )) )
  138.         (cond ((symbolp (car listr)) (setq %let-list (cons `(,(car listr) nil) %let-list)))
  139.               ((atom (car listr))
  140.                (error #+DEUTSCH "Im Macro ~S ist als &AUX-Variable nicht verwendbar: ~S"
  141.                       #+ENGLISH "in macro ~S: ~S may not be used as &AUX variable."
  142.                       #+FRANCAIS "Dans le macro ~S, l'utilisation de ~S n'est pas possible comme variable &AUX."
  143.                       name (car listr)
  144.               ))
  145.               (t (setq %let-list
  146.                    (cons `(,(caar listr) ,(cadar listr)) %let-list)
  147.   ) ) ) )     )  )
  148. )
  149.  
  150. (%putd 'analyze-key
  151.   (function analyze-key
  152.     (lambda (lambdalistr restvar name &aux (otherkeysforbidden t) (kwlist nil))
  153.       (do ((listr lambdalistr (cdr listr))
  154.            (next)
  155.            (kw)
  156.            (svar)
  157.            (g))
  158.           ((atom listr)
  159.            (if listr
  160.              (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  161.                      #+ENGLISH "The rest of the lambda list will be ignored."
  162.                      #+FRANCAIS "Ignorer ce qui suit."
  163.                      #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &KEY."
  164.                      #+ENGLISH "The lambda list of macro ~S contains a dot after &KEY."
  165.                      #+FRANCAIS "La liste lambda du macro ~S contient un point après &KEY."
  166.                      name
  167.           )) )
  168.         (setq next (car listr))
  169.         (cond ((eq next '&ALLOW-OTHER-KEYS) (setq otherkeysforbidden nil))
  170.               ((eq next '&AUX) (return-from nil (analyze-aux (cdr listr) name)))
  171.               ((or (eq next '&ENVIRONMENT) (eq next '&WHOLE) (eq next '&OPTIONAL)
  172.                    (eq next '&REST) (eq next '&BODY) (eq next '&KEY)
  173.                )
  174.                (cerror #+DEUTSCH "Es wird ignoriert."
  175.                        #+ENGLISH "It will be ignored."
  176.                        #+FRANCAIS "Ignorer ce qui suit."
  177.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein ~S an falscher Stelle."
  178.                        #+ENGLISH "The lambda list of macro ~S contains a badly placed ~S."
  179.                        #+FRANCAIS "La liste lambda du macro ~S contient un ~S mal placé."
  180.                        name next
  181.               ))
  182.               (t
  183.                 (if %default-form
  184.                   (cond ((symbolp next) (setq next (list next %default-form)))
  185.                         ((and (consp next) (eql (length next) 1))
  186.                          (setq next (list (car next) %default-form))
  187.                 ) )     )
  188.                 (cond ((symbolp next)
  189.                        (setq kw (intern (symbol-name next) *keyword-package*))
  190.                        (setq %let-list
  191.                          (cons `(,next (GETF ,restvar ,kw NIL)) %let-list)
  192.                        )
  193.                        (setq kwlist (cons kw kwlist))
  194.                       )
  195.                       ((atom next)
  196.                        (cerror #+DEUTSCH "Es wird ignoriert."
  197.                                #+ENGLISH "It will be ignored."
  198.                                #+FRANCAIS "Il sera ignoré."
  199.                                #+DEUTSCH "Die Lambdaliste des Macros ~S enthält folgendes unpassende Element: ~S"
  200.                                #+ENGLISH "The lambda list of macro ~S contains the invalid element ~S"
  201.                                #+FRANCAIS "La liste lambda du macro ~S contient cet élément inadmissible : ~S"
  202.                                name next
  203.                       ))
  204.                       ((symbolp (car next))
  205.                        (setq kw (intern (symbol-name (car next)) *keyword-package*))
  206.                        (setq %let-list
  207.                          (cons `(,(car next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  208.                                %let-list
  209.                        ) )
  210.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  211.                                     (third next)
  212.                                     nil
  213.                        )          )
  214.                        (setq %let-list
  215.                          (cons
  216.                            (if svar
  217.                              `(,svar (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  218.                                        (PROGN (SETQ ,(car next) ,(cadr next)) NIL)
  219.                                        T
  220.                               )      )
  221.                              `(,(car next) (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  222.                                              ,(cadr next)
  223.                                              ,(car next)
  224.                               )            )
  225.                            )
  226.                            %let-list
  227.                        ) )
  228.                        (setq kwlist (cons kw kwlist))
  229.                       )
  230.                       ((not (and (consp (car next)) (keywordp (caar next)) (consp (cdar next))))
  231.                        (cerror #+DEUTSCH "Es wird ignoriert."
  232.                                #+ENGLISH "It will be ignored."
  233.                                #+FRANCAIS "Elle sera ignorée."
  234.                                #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige Keywordspezifikation: ~S"
  235.                                #+ENGLISH "The lambda list of macro ~S contains an invalid keyword specification ~S"
  236.                                #+FRANCAIS "La liste lambda du macro ~S contient une spécification de mot-clé inadmissible : ~S"
  237.                                name (car next)
  238.                       ))
  239.                       ((symbolp (cadar next))
  240.                        (setq kw (caar next))
  241.                        (setq %let-list
  242.                          (cons `(,(cadar next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  243.                            %let-list
  244.                        ) )
  245.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  246.                                     (third next)
  247.                                     nil
  248.                        )          )
  249.                        (setq %let-list
  250.                          (cons
  251.                            (if svar
  252.                              `(,svar (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  253.                                        (PROGN (SETQ ,(cadar next) ,(cadr next)) NIL)
  254.                                        T
  255.                               )      )
  256.                              `(,(cadar next) (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  257.                                              ,(cadr next)
  258.                                              ,(cadar next)
  259.                               )            )
  260.                            )
  261.                            %let-list
  262.                        ) )
  263.                        (setq kwlist (cons kw kwlist))
  264.                       )
  265.                       (t
  266.                        (setq kw (caar next))
  267.                        (setq g (gensym))
  268.                        (setq %let-list
  269.                          (cons `(,g (GETF ,restvar ,kw MACRO-MISSING-VALUE)) %let-list)
  270.                        )
  271.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  272.                                     (third next)
  273.                                     nil
  274.                        )          )
  275.                        (setq %let-list
  276.                          (cons
  277.                            (if svar
  278.                              `(,svar (IF (EQ ,g MACRO-MISSING-VALUE)
  279.                                        (PROGN (SETQ ,g ,(cadr next)) NIL)
  280.                                        T
  281.                               )      )
  282.                              `(,g (IF (EQ ,g MACRO-MISSING-VALUE)
  283.                                     ,(cadr next)
  284.                                     ,(cadar next)
  285.                               )   )
  286.                            )
  287.                            %let-list
  288.                        ) )
  289.                        (setq kwlist (cons kw kwlist))
  290.                        (let ((%min-args 0) (%arg-count 0) (%restp nil) (%default-form nil))
  291.                          (analyze1 (cadar next) g name g)
  292.                       ))
  293.               ) )
  294.       ) )
  295.       (if otherkeysforbidden
  296.         (setq %keyword-tests
  297.           (cons `(KEYWORD-TEST ,restvar ',kwlist) %keyword-tests)
  298.       ) )
  299.   ) )
  300. )
  301.  
  302. (%putd 'analyze-rest
  303.   (function analyze-rest
  304.     (lambda (lambdalistr restexp name)
  305.       (if (atom lambdalistr)
  306.         (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält keine Variable nach &REST/&BODY."
  307.                #+ENGLISH "The lambda list of macro ~S is missing a variable after &REST/&BODY."
  308.                #+FRANCAIS "Il manque une variable après &REST/BODY dans la liste lambda du macro ~S."
  309.                name
  310.       ) )
  311.       (unless (symbolp (car lambdalistr))
  312.         (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige Variable nach &REST/&BODY: ~S"
  313.                #+ENGLISH "The lambda list of macro ~S contains an illegal variable after &REST/&BODY: ~S"
  314.                #+FRANCAIS "La liste lambda du macro ~S contient une variable indamissible après &REST/BODY : ~S"
  315.                name (car lambdalistr)
  316.       ) )
  317.       (let ((restvar (car lambdalistr))
  318.             (listr (cdr lambdalistr)))
  319.         (setq %restp t)
  320.         (setq %let-list (cons `(,restvar ,restexp) %let-list))
  321.         (cond ((null listr))
  322.               ((atom listr)
  323.                (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  324.                        #+ENGLISH "The rest of the lambda list will be ignored."
  325.                        #+FRANCAIS "Ignorer ce qui suit."
  326.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt an falscher Stelle."
  327.                        #+ENGLISH "The lambda list of macro ~S contains a misplaced dot."
  328.                        #+FRANCAIS "La liste lambda du macro ~S contient un point mal placé."
  329.                        name
  330.               ))
  331.               ((eq (car listr) '&KEY) (analyze-key (cdr listr) restvar name))
  332.               ((eq (car listr) '&AUX) (analyze-aux (cdr listr) name))
  333.               (t (cerror #+DEUTSCH "Dieser ganze Teil wird ignoriert."
  334.                          #+ENGLISH "They will be ignored."
  335.                          #+FRANCAIS "Ignorer cette partie."
  336.                          #+DEUTSCH "Die Lambdaliste des Macros ~S enthält überflüssige Elemente: ~S"
  337.                          #+ENGLISH "The lambda list of macro ~S contains superfluous elements: ~S"
  338.                          #+FRANCAIS "La liste lambda du macro ~S contient des éléments superflus : ~S"
  339.                          name listr
  340.   ) ) ) )     )  )
  341. )
  342.  
  343. (%putd 'cons-car
  344.   (function cons-car
  345.     (lambda (exp &aux h)
  346.       (if
  347.         (and
  348.           (consp exp)
  349.           (setq h
  350.             (assoc (car exp)
  351.               '((car . caar) (cdr . cadr)
  352.                 (caar . caaar) (cadr . caadr) (cdar . cadar) (cddr . caddr)
  353.                 (caaar . caaaar) (caadr . caaadr) (cadar . caadar) (caddr . caaddr)
  354.                 (cdaar . cadaar) (cdadr . cadadr) (cddar . caddar) (cdddr . cadddr)
  355.                 (cddddr . fifth)
  356.         ) ) )  )
  357.         (cons (cdr h) (cdr exp))
  358.         (list 'car exp)
  359.   ) ) )
  360. )
  361.  
  362. (%putd 'cons-cdr
  363.   (function cons-cdr
  364.     (lambda (exp &aux h)
  365.       (if
  366.         (and
  367.           (consp exp)
  368.           (setq h
  369.             (assoc (car exp)
  370.               '((car . cdar) (cdr . cddr)
  371.                 (caar . cdaar) (cadr . cdadr) (cdar . cddar) (cddr . cdddr)
  372.                 (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) (caddr . cdaddr)
  373.                 (cdaar . cddaar) (cdadr . cddadr) (cddar . cdddar) (cdddr . cddddr)
  374.         ) ) )  )
  375.         (cons (cdr h) (cdr exp))
  376.         (list 'cdr exp)
  377.   ) ) )
  378. )
  379.  
  380. (%putd 'analyze1
  381.   (function analyze1
  382.     (lambda (lambdalist accessexp name wholevar)
  383.       (do ((listr lambdalist (cdr listr))
  384.            (withinoptional nil)
  385.            (item)
  386.            (g))
  387.           ((atom listr)
  388.            (when listr
  389.              (unless (symbolp listr)
  390.                (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige &REST-Variable: ~S"
  391.                       #+ENGLISH "The lambda list of macro ~S contains an illegal &REST variable: ~S"
  392.                       #+FRANCAIS "La liste lambda du macro ~S contient une variable &REST inadmissible : ~S"
  393.                       name listr
  394.              ) )
  395.              (setq %let-list (cons `(,listr ,accessexp) %let-list))
  396.              (setq %restp t)
  397.           ))
  398.         (setq item (car listr))
  399.         (cond ((eq item '&WHOLE)
  400.                (if (and wholevar (cdr listr) (symbolp (cadr listr)))
  401.                  (progn
  402.                    (setq %let-list (cons `(,(cadr listr) ,wholevar) %let-list))
  403.                    (setq listr (cdr listr))
  404.                  )
  405.                  (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein unzulässiges &WHOLE: ~S"
  406.                         #+ENGLISH "The lambda list of macro ~S contains an invalid &WHOLE: ~S"
  407.                         #+FRANCAIS "La liste lambda du macro ~S contient un &WHOLE inadmissible : ~S"
  408.                         name listr
  409.               )) )
  410.               ((eq item '&OPTIONAL)
  411.                (if withinoptional
  412.                  (cerror #+DEUTSCH "Es wird ignoriert."
  413.                          #+ENGLISH "It will be ignored."
  414.                          #+FRANCAIS "L'ignorer."
  415.                          #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein überflüssiges ~S."
  416.                          #+ENGLISH "The lambda list of macro ~S contains a superfluous ~S."
  417.                          #+FRANCAIS "La liste lambda du macro ~S contient un ~S superflu."
  418.                          name item
  419.                ) )
  420.                (setq withinoptional t)
  421.               )
  422.               ((or (eq item '&REST) (eq item '&BODY))
  423.                (return-from nil (analyze-rest (cdr listr) accessexp name))
  424.               )
  425.               ((eq item '&KEY)
  426.                (setq g (gensym))
  427.                (setq %restp t)
  428.                (setq %let-list (cons `(,g ,accessexp) %let-list))
  429.                (return-from nil (analyze-key (cdr listr) g name))
  430.               )
  431.               ((eq item '&ALLOW-OTHER-KEYS)
  432.                (cerror #+DEUTSCH "Es wird ignoriert."
  433.                        #+ENGLISH "It will be ignored."
  434.                        #+FRANCAIS "L'ignorer."
  435.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ~S vor &KEY."
  436.                        #+ENGLISH "The lambda list of macro ~S contains ~S before &KEY."
  437.                        #+FRANCAIS "La liste lambda du macro ~S contient ~S avant &KEY."
  438.                        name item
  439.               ))
  440.               ((eq item '&ENVIRONMENT)
  441.                (cerror #+DEUTSCH "Es wird ignoriert."
  442.                        #+ENGLISH "It will be ignored."
  443.                        #+FRANCAIS "L'ignorer."
  444.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ~S, was hier unzulässig ist."
  445.                        #+ENGLISH "The lambda list of macro ~S contains ~S which is illegal here."
  446.                        #+FRANCAIS "La liste lambda du macro ~S contient ~S qui est inadmissible ici."
  447.                        name item
  448.               ))
  449.               ((eq item '&AUX)
  450.                (return-from nil (analyze-aux (cdr listr) name))
  451.               )
  452.               (withinoptional
  453.                (setq %arg-count (1+ %arg-count))
  454.                (if %default-form
  455.                  (cond ((symbolp item) (setq item (list item %default-form)))
  456.                        ((and (consp item) (eql (length item) 1))
  457.                         (setq item (list (car item) %default-form))
  458.                ) )     )
  459.                (cond ((symbolp item)
  460.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  461.                      )
  462.                      ((atom item)
  463.                       #1=
  464.                       (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein unzulässiges Element: ~S"
  465.                              #+ENGLISH "The lambda list of macro ~S contains an invalid element ~S"
  466.                              #+FRANCAIS "La liste lambda du macro ~S contient un élément inadmissible : ~S"
  467.                              name item
  468.                      ))
  469.                      ((symbolp (car item))
  470.                       (setq %let-list
  471.                         (cons `(,(car item) (IF ,accessexp
  472.                                               ,(cons-car accessexp)
  473.                                               ,(if (consp (cdr item)) (cadr item) 'NIL)
  474.                                )            )
  475.                           %let-list
  476.                       ) )
  477.                       (when (and (consp (cdr item)) (consp (cddr item)))
  478.                         (unless (symbolp (caddr item))
  479.                           (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige supplied-Variable: ~S"
  480.                                  #+ENGLISH "The lambda list of macro ~S contains an invalid supplied-variable ~S"
  481.                                  #+FRANCAIS "La liste lambda du macro ~S contient une «supplied-variable» indamissible : ~S"
  482.                                  name (caddr item)
  483.                         ) )
  484.                         (setq %let-list
  485.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  486.                      )) )
  487.                      (t
  488.                       (setq g (gensym))
  489.                       (setq %let-list
  490.                         (cons `(,g ,(if (consp (cdr item))
  491.                                       `(IF ,accessexp
  492.                                          ,(cons-car accessexp)
  493.                                          ,(cadr item)
  494.                                        )
  495.                                       (cons-car accessexp)
  496.                                )    )
  497.                           %let-list
  498.                       ) )
  499.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  500.                         (analyze1 (car item) g name g)
  501.                       )
  502.                       (if (consp (cddr item))
  503.                         (setq %let-list
  504.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  505.                )     )) )
  506.                (setq accessexp (cons-cdr accessexp))
  507.               )
  508.               (t ; notwendige Argumente
  509.                (setq %min-args (1+ %min-args))
  510.                (setq %arg-count (1+ %arg-count))
  511.                (cond ((symbolp item)
  512.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  513.                      )
  514.                      ((atom item)
  515.                       #1# ; (error ... name item), s.o.
  516.                      )
  517.                      (t
  518.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  519.                         (analyze1 item (cons-car accessexp) name (cons-car accessexp))
  520.                )     ))
  521.                (setq accessexp (cons-cdr accessexp))
  522.   ) ) ) )     )
  523. )
  524.  
  525. (%putd 'remove-env-arg
  526.   (function remove-env-arg
  527.     (lambda (lambdalist name)
  528.       (do ((listr lambdalist (cdr listr)))
  529.           ((atom listr) (values lambdalist nil))
  530.         (if (eq (car listr) '&ENVIRONMENT)
  531.           (if (and (consp (cdr listr)) (symbolp (cadr listr)) (cadr listr))
  532.             ; &ENVIRONMENT gefunden
  533.             (return
  534.               (values
  535.                 (do ((l1 lambdalist (cdr l1)) ; lambdalist ohne &ENVIRONMENT/Symbol
  536.                      (l2 nil (cons (car l1) l2)))
  537.                     ((eq (car l1) '&ENVIRONMENT)
  538.                      (nreconc l2 (cddr l1))
  539.                 )   )
  540.                 (cadr listr)
  541.             ) )
  542.             (error #+DEUTSCH "In der Lambdaliste des Macros ~S muß nach &ENVIRONMENT ein Symbol (nicht NIL) folgen: ~S"
  543.                    #+ENGLISH "In the lambda list of macro ~S, &ENVIRONMENT must be followed by a non-NIL symbol: ~S"
  544.                    #+FRANCAIS "Dans la liste lambda du macro ~S, &ENVIRONMENT doit être suivi par un symbole autre que NIL : ~S"
  545.                    name lambdalist
  546.           ) )
  547.   ) ) ) )
  548. )
  549.  
  550. (%putd 'make-length-test
  551.   (function make-length-test
  552.     (lambda (var)
  553.       (cond ((and (zerop %min-args) %restp) NIL)
  554.             ((zerop %min-args) `(> (LENGTH ,var) ,(1+ %arg-count)))
  555.             (%restp `(< (LENGTH ,var) ,(1+ %min-args)))
  556.             ((= %min-args %arg-count) `(/= (LENGTH ,var) ,(1+ %min-args)))
  557.             (t `(NOT (<= ,(1+ %min-args) (LENGTH ,var) ,(1+ %arg-count))))
  558.   ) ) )
  559. )
  560.  
  561. (%putd 'make-macro-expansion
  562.   (function make-macro-expansion
  563.     (lambda (macrodef)
  564.       (if (atom macrodef)
  565.         (error #+DEUTSCH "Daraus kann kein Macro definiert werden: ~S"
  566.                #+ENGLISH "Cannot define a macro from that: ~S"
  567.                #+FRANCAIS "Aucun macro n'est définissable à partir de ~S"
  568.                macrodef
  569.       ) )
  570.       (unless (symbolp (car macrodef))
  571.         (error #+DEUTSCH "Der Name eines Macros muß ein Symbol sein, nicht: ~S"
  572.                #+ENGLISH "The name of a macro must be a symbol, not ~S"
  573.                #+FRANCAIS "Le nom d'un macro doit être un symbole et non ~S"
  574.                (car macrodef)
  575.       ) )
  576.       (if (atom (cdr macrodef))
  577.         (error #+DEUTSCH "Der Macro ~S hat keine Lambdaliste."
  578.                #+ENGLISH "Macro ~S is missing a lambda list."
  579.                #+FRANCAIS "Le macro ~S ne possède pas de liste lambda."
  580.                (car macrodef)
  581.       ) )
  582.       (let ((name (car macrodef))
  583.             (lambdalist (cadr macrodef))
  584.             (body (cddr macrodef))
  585.            )
  586.         (multiple-value-bind (body-rest declarations docstring)
  587.                              (parse-body body t) ; globales Environment!
  588.           (if declarations (setq declarations (list (cons 'DECLARE declarations))))
  589.           (multiple-value-bind (newlambdalist envvar)
  590.                                (remove-env-arg lambdalist name)
  591.             (let ((%arg-count 0) (%min-args 0) (%restp nil)
  592.                   (%let-list nil) (%keyword-tests nil) (%default-form nil))
  593.               (analyze1 newlambdalist '(CDR <MACRO-FORM>) name '<MACRO-FORM>)
  594.               (let ((lengthtest (make-length-test '<MACRO-FORM>))
  595.                     (mainform `(LET* ,(nreverse %let-list)
  596.                                  ,@declarations
  597.                                  ,@(nreverse %keyword-tests)
  598.                                  ,@body-rest
  599.                    ))          )
  600.                 (if lengthtest
  601.                   (setq mainform
  602.                     `(IF ,lengthtest
  603.                        (MACRO-CALL-ERROR <MACRO-FORM>)
  604.                        ,mainform
  605.                 ) )  )
  606.                 (values
  607.                   `(FUNCTION ,name
  608.                      (LAMBDA (<MACRO-FORM> &OPTIONAL ,(or envvar '<ENV-ARG>))
  609.                        (DECLARE (CONS <MACRO-FORM>))
  610.                        ,@(unless envvar '((DECLARE (IGNORE <ENV-ARG>))))
  611.                        ,@(if docstring (list docstring))
  612.                        (BLOCK ,name ,mainform)
  613.                    ) )
  614.                   name
  615.                   lambdalist
  616.                   docstring
  617.   ) ) ) ) ) ) ) )
  618. )
  619.  
  620. (%putd 'make-macro-expandercons
  621.   (function make-macro-expandercons
  622.     (lambda (macrodef)
  623.       (cons 'MACRO (eval (make-macro-expansion macrodef)))
  624. ) ) )
  625.